home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / tptool.lbr / CHAPTER2.PQS / chapter2.pas
Pascal/Delphi Source File  |  1985-06-03  |  6KB  |  299 lines
  1. {$A-}
  2. PROGRAM chapter2;
  3. {$I TOOLU.PAS}
  4.  
  5. PROCEDURE OVERSTRIKE;
  6. CONST
  7.   SKIP=BLANK;
  8.   NOSKIP=PLUS;
  9. VAR
  10.   C:CHARACTER;
  11.   COL,NEWCOL,I:INTEGER;
  12. BEGIN
  13.   COL:=1;
  14.   REPEAT
  15.     NEWCOL:=COL;
  16.     WHILE(GETC(C)=BACKSPACE) DO
  17.       NEWCOL:=MAX(NEWCOL-1,1);
  18.     IF (NEWCOL<COL) THEN BEGIN
  19.       PUTC(NEWLINE);
  20.       PUTC(NOSKIP);
  21.       FOR I:=1 TO NEWCOL-1 DO
  22.         PUTC(BLANK);
  23.       COL:=NEWCOL
  24.     END
  25.     ELSE IF (COL=1) AND (C<>ENDFILE) THEN
  26.       PUTC(SKIP);
  27.     IF(C<>ENDFILE)THEN BEGIN
  28.       PUTC(C);
  29.       IF (C=NEWLINE) THEN
  30.         COL:=1
  31.       ELSE
  32.         COL:=COL+1
  33.       END
  34.     UNTIL (C=ENDFILE)
  35.   END;
  36.  
  37. PROCEDURE COMPRESS;
  38. CONST
  39.   WARNING=CARET;
  40. VAR
  41.   C,LASTC:CHARACTER;
  42.   N:INTEGER;
  43.  
  44. PROCEDURE PUTREP(N:INTEGER;C:CHARACTER);CONST
  45.   MAXREP=26;
  46.   THRESH=4;
  47. BEGIN
  48.   WHILE(N>=THRESH)OR((C=WARNING)AND(N>0))DO BEGIN
  49.     PUTC(WARNING);
  50.     PUTC(MIN(N,MAXREP)-1+ORD('A'));
  51.     PUTC(C);
  52.     N:=N-MAXREP
  53.   END;
  54.   FOR N:=N DOWNTO 1 DO
  55.     PUTC(C)
  56.   END;
  57.  
  58. BEGIN(*COMPRESS*)
  59.   N:=1;
  60.   LASTC:=GETC(LASTC);
  61.   WHILE(LASTC<>ENDFILE) DO BEGIN
  62.     IF(GETC(C)=ENDFILE)THEN BEGIN
  63.       IF(N>1) OR(LASTC=WARNING) THEN
  64.         PUTREP(N,LASTC)
  65.       ELSE
  66.         PUTC(LASTC)
  67.       END
  68.       ELSE IF (C=LASTC) THEN
  69.         N:=N+1
  70.       ELSE IF (N>1) OR (LASTC=WARNING) THEN BEGIN
  71.         PUTREP(N,LASTC);
  72.         N:=1
  73.       END
  74.       ELSE
  75.          PUTC(LASTC);
  76.       LASTC:=C
  77.     END
  78.   END;
  79.   
  80.   PROCEDURE EXPAND;
  81.   CONST
  82.     WARNING=CARET;
  83.    VAR
  84.      C:CHARACTER;
  85.      N:INTEGER;
  86.   BEGIN
  87.     WHILE(GETC(C)<>ENDFILE) DO
  88.       IF (C<>WARNING)THEN
  89.         PUTC(C)
  90.       ELSE IF(ISUPPER(GETC(C))) THEN BEGIN
  91.         N:=C-ORD('A')+1;
  92.         IF(GETC(C)<>ENDFILE)THEN
  93.           FOR N:=N DOWNTO 1 DO
  94.             PUTC(C)
  95.           ELSE BEGIN
  96.             PUTC(WARNING);
  97.             PUTC(N-1+ORD('A'))
  98.           END
  99.       END
  100.       ELSE BEGIN
  101.         PUTC(WARNING);
  102.         IF(C<>ENDFILE) THEN
  103.           PUTC(C)
  104.       END
  105.   END;
  106.  
  107.  
  108. PROCEDURE ECHO;
  109. VAR
  110.   I,J:INTEGER;
  111.   ARGSTR:XSTRING;
  112. BEGIN
  113.   I:=2;
  114.   WHILE(GETARG(I,ARGSTR,MAXSTR))DO BEGIN
  115.     IF(I>2) THEN PUTC(BLANK);
  116.     FOR J:=1 TO XLENGTH(ARGSTR) DO
  117.       PUTC(ARGSTR[J]);
  118.     I:=I+1
  119.   END;
  120.   IF(I>1)THEN PUTC(NEWLINE)
  121. END;
  122.  
  123.  
  124.  
  125. PROCEDURE ENTAB;
  126. CONST
  127.   MAXLINE=1000;
  128. TYPE
  129.   TABTYPE=ARRAY[1..MAXLINE] OF BOOLEAN;
  130. VAR
  131.   C:CHARACTER;
  132.   COL,NEWCOL:INTEGER;
  133.   TABSTOPS:TABTYPE;
  134.  
  135. FUNCTION TABPOS(COL:INTEGER;VAR TABSTOPS:TABTYPE):BOOLEAN;
  136. BEGIN
  137.   IF(COL>MAXLINE)THEN
  138.     TABPOS:=TRUE
  139.   ELSE
  140.     TABPOS:=TABSTOPS[COL]
  141. END;
  142.  
  143. PROCEDURE SETTABS(VAR TABSTOPS:TABTYPE);
  144. CONST
  145.   TABSPACE=TabSpaces;    { K&P was 4 }
  146. VAR
  147.   I:INTEGER;
  148. BEGIN
  149.   FOR I:=1 TO MAXLINE DO
  150.     TABSTOPS[I]:=(I MOD TABSPACE = 1)
  151. END;
  152.  
  153.     BEGIN
  154.   SETTABS(TABSTOPS);
  155.   COL:=1;
  156.   REPEAT
  157.     NEWCOL:=COL;
  158.     WHILE(GETC(C)=BLANK) DO BEGIN
  159.       NEWCOL:=NEWCOL+1;
  160.       IF(TABPOS(NEWCOL,TABSTOPS))THEN BEGIN
  161.         PUTC(TAB);
  162.         COL:=NEWCOL;
  163.       END
  164.     END;
  165.     WHILE (COL<NEWCOL) DO BEGIN
  166.       PUTC(BLANK);
  167.       COL:=COL+1
  168.     END;
  169.     IF(C<>ENDFILE) THEN BEGIN
  170.       PUTC(C);
  171.       IF(C=NEWLINE) THEN
  172.         COL:=1
  173.       ELSE
  174.         COL:=COL+1
  175.       END
  176.     UNTIL(C=ENDFILE)
  177.   END;
  178.  
  179.  
  180.  
  181. PROCEDURE TRANSLIT;
  182. CONST
  183.   NEGATE=CARET;
  184. VAR
  185.   ARG,FROMSET,TOSET:XSTRING;
  186.   C:CHARACTER;
  187.   I,LASTTO:0..MAXSTR;
  188.   ALLBUT,SQUASH:BOOLEAN;
  189. FUNCTION XINDEX(VAR INSET:XSTRING;C:CHARACTER;
  190.   ALLBUT:BOOLEAN;LASTTO:INTEGER):INTEGER;
  191. BEGIN
  192.   IF(C=ENDFILE)THEN XINDEX:=0
  193.   ELSE IF (NOT ALLBUT) THEN
  194.     XINDEX:=INDEX(INSET,C)
  195.   ELSE IF(INDEX(INSET,C)>0)THEN
  196.     XINDEX:=0
  197.   ELSE
  198.     XINDEX:=LASTTO+1
  199. END;
  200.   
  201. FUNCTION MAKESET(VAR INSET:XSTRING;K:INTEGER;
  202.   VAR OUTSET:XSTRING;MAXSET:INTEGER):BOOLEAN;
  203.  
  204. VAR J:INTEGER;
  205.  
  206. PROCEDURE DODASH(DELIM:CHARACTER;VAR SRC:XSTRING;
  207.   VAR I:INTEGER;VAR DEST:XSTRING;
  208.   VAR J:INTEGER;MAXSET:INTEGER);
  209. VAR
  210.   K:INTEGER;
  211.   JUNK:BOOLEAN;
  212. BEGIN
  213.   WHILE (SRC[I]<>DELIM)AND(SRC[I]<>ENDSTR)DO BEGIN
  214.     IF(SRC[I]=ATSIGN)THEN
  215.       JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
  216.     ELSE IF (SRC[I]<>DASH) THEN
  217.       JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
  218.     ELSE IF (J<=1)OR(SRC[I+1]=ENDSTR)THEN
  219.       JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
  220.     ELSE IF (ISALPHANUM(SRC[I-1]))
  221.       AND (ISALPHANUM(SRC[I+1]))
  222.       AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
  223.         FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
  224.           JUNK:=ADDSTR(K,DEST,J,MAXSET);
  225.         I:=I+1
  226.       END
  227.     ELSE
  228.       JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
  229.     I:=I+1
  230.   END
  231.   
  232. END;(*DODASH*)
  233.  
  234. BEGIN(*MAKESET*)
  235.   J:=1;
  236.   DODASH(ENDSTR,INSET,K,OUTSET,J,MAXSET);
  237.   MAKESET:=ADDSTR(ENDSTR,OUTSET,J,MAXSET)
  238. END;(*MAKESET*)
  239.  
  240. BEGIN(*TRANSLIT*)
  241.   IF (NOT GETARG(2,ARG,MAXSTR))THEN
  242.     ERROR('Usage: TRANSLIT from to');
  243.   ALLBUT:=(ARG[1]=NEGATE);
  244.   IF(ALLBUT)THEN
  245.     I:=2
  246.   ELSE
  247.     I:=1;
  248.   IF (NOT MAKESET(ARG,I,FROMSET,MAXSTR)) THEN
  249.     ERROR('Translit: "from" set too large');
  250.   IF(NOT GETARG(3,ARG,MAXSTR))THEN
  251.     TOSET[1]:=ENDSTR
  252.   ELSE IF (NOT MAKESET(ARG,1,TOSET,MAXSTR)) THEN
  253.     ERROR('translit: "to" set too large')
  254.   ELSE IF (XLENGTH(FROMSET)<XLENGTH(TOSET))THEN
  255.     ERROR('translit: "from" shorter than "to"');
  256.  
  257.   LASTTO:=XLENGTH(TOSET);
  258.   SQUASH:=(XLENGTH(FROMSET)>LASTTO) OR (ALLBUT);
  259.   REPEAT
  260.     I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO);
  261.     IF (SQUASH) AND(I>=LASTTO) AND (LASTTO>0) THEN BEGIN
  262.       PUTC(TOSET[LASTTO]);
  263.       REPEAT
  264.         I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO)
  265.       UNTIL (I<LASTTO)
  266.     END;
  267.     IF(C<>ENDFILE) THEN BEGIN
  268.       IF(I>0)AND(LASTTO>0) THEN
  269.         PUTC(TOSET[I])
  270.       ELSE IF (I=0)THEN
  271.         PUTC(C)
  272.       (*ELSE DELETE*)
  273.     END
  274.   UNTIL(C=ENDFILE)
  275. END;
  276.  
  277.  
  278.  
  279.  
  280.  
  281. PROCEDURE COMMAND;
  282.  
  283. BEGIN
  284.      if GlobalArg1='entab' THEN ENTAB
  285. ELSE IF GlobalArg1='overstrike' THEN OVERSTRIKE
  286. ELSE IF GlobalArg1='compress' THEN COMPRESS
  287. ELSE IF GlobalArg1='expand' THEN EXPAND
  288. ELSE IF GlobalArg1='echo' THEN ECHO
  289. ELSE IF GlobalArg1='translit' THEN TRANSLIT
  290. ELSE ERROR('Chap 2: can''t happen');
  291. END;(*COMMAND*)
  292.  
  293.  
  294. BEGIN
  295.     COMMAND;
  296.     ENDCMD;
  297. END.
  298.  
  299.